module Interpret (run, safeRun, safego) where
import Common
import Data.Char (chr,ord)
import Control.Monad (when)
import Data.Array.IO
import Data.Array.Base
import Data.IORef

runWith f !n = do
  arr <- newArray (0,40000) 0 :: IO (IOUArray Int Int)
  -- ref <- newIORef 0 :: IO (IORef Int)
  f arr 0 $! n 
  return () 

run = runWith go
safeRun = undefined -- runWith safego

go :: IOUArray Int Int -> Int -> [Operation] -> IO Int
go !a !p (x:xs) 
 | a `seq` p `seq` x `seq` xs `seq` False = undefined
 | otherwise = do
   p' <- case x of
    (o :<- v) -> let loc = p+o in loc `seq` v `seq` unsafeWrite a loc v >> (return $! p)
    (o :+= v) -> do prev <- unsafeRead a (p+o)
                    unsafeWrite a (p+o) $! (v+prev)
                    return $! p
    MoveOp o     -> return $! (p+o)
    OpLocSetT o1 o2 v -> do src <- unsafeRead a $! (p+o2)
                            unsafeWrite a (p+o1) $! (v * src)
                            return $! p
    OpLocAddT o1 o2 v -> do src <- unsafeRead a $! (p+o2)
                            curr <- unsafeRead a $! (p+o1)
                            unsafeWrite a (p+o1) $! (curr + v*src)
                            return $! p
    LoopOp While ops -> do curr <- unsafeRead a p
                           if curr /= 0 then (go a p ops >>= \np -> np `seq` go a np [x]) else (return $! p)
    LoopOp DoWhile ops -> go a p ops >>= \np -> np `seq` go a np [LoopOp While ops]
    LoopOp If ops -> do curr <- unsafeRead a p
                        if curr /= 0 then go a p ops else return $! p
    PutcOp (Const i) -> do putChar . chr $! i
                           return $! p
    PutcOp (Str s)   -> putStr (map chr s) >> (return $! p)
    PutcOp (Ptr o) -> do val <- unsafeRead a $! (p+o)
                         putChar . chr $! val
                         return $! p
    GetcOp       -> do inp <- getChar
                       unsafeWrite a p (ord inp)
                       return $! p
   p2 <- return $! p'
   a `seq` p' `seq` go a p2 $! xs

go _  !p []  = return $! p
  

safego !a !r xa@(x:xs) = do
   p <- readIORef r
   case x of
    (o :<- v) -> writeArray a (p+o) v
    (o :+= v) -> do prev <- readArray a (p+o)
                    writeArray a (p+o) (v+prev)
    MoveOp o     -> writeIORef r (p+o)
    LoopOp While ops -> do curr <- readArray a p
                           when (curr /= 0) ((safego a r) ops >> safego a r [x])
    LoopOp DoWhile ops -> (safego a r) ops >> (safego a r [LoopOp While ops])
    LoopOp If ops -> do curr <- readArray a p
                        when (curr /= 0) $ safego a r ops
    OpLocAddT o1 o2 v -> do src <- readArray a (p+o2)
                            curr <- readArray a (p+o1)
                            writeArray a (p+o1) (curr + v*src)
    PutcOp (Const i) -> putChar . chr $ i
    PutcOp (Str s) -> putStr (map chr s) 
    PutcOp (Ptr o) -> do val <- readArray a (p+o)
                         putChar . chr $ val
    GetcOp       -> do inp <- getChar
                       writeArray a p (ord inp)
    OpLocSetT o1 o2 v -> do src <- readArray a (p+o2)
                            writeArray a (p+o1) (v * src)
                            writeArray a (p+o1) (v * src)
   safego a r xs
